home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / a-tags.adb < prev    next >
Text File  |  1996-01-30  |  7KB  |  205 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                             A D A . T A G S                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.9 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Unchecked_Conversion;
  27. package body Ada.Tags is
  28.  
  29.    type Dispatch_Table is record
  30.       Idepth : Natural;
  31.       Tags   : System.Address;
  32.       Fptrs  : Address_Array (Positive);
  33.    end record;
  34.  
  35.    subtype Big_Address_Array is Address_Array (Natural);
  36.    type Address_Array_Ptr is access all Big_Address_Array;
  37.  
  38.    function To_Address_Array_Ptr is
  39.      new Unchecked_Conversion (System.Address, Address_Array_Ptr);
  40.  
  41.    function To_Address is new Unchecked_Conversion (Tag, System.Address);
  42.  
  43.    -------------------
  44.    -- Expanded_Name --
  45.    -------------------
  46.  
  47.    function Expanded_Name (T : Tag) return String is
  48.    begin
  49.       raise Program_Error; -- TBSL ???
  50.       return "";
  51.    end Expanded_Name;
  52.  
  53.    ------------------
  54.    -- External_Tag --
  55.    ------------------
  56.  
  57.    function External_Tag (T : Tag) return String is
  58.    begin
  59.       raise Program_Error; -- TBSL  ???
  60.       return "";
  61.    end External_Tag;
  62.  
  63.    ------------------
  64.    -- Internal_Tag --
  65.    ------------------
  66.  
  67.    function Internal_Tag (External : String) return Tag is
  68.    begin
  69.       raise Program_Error; -- TBSL  ???
  70.       return null;
  71.    end Internal_Tag;
  72.  
  73.    -------------------------
  74.    -- Set_Prim_Op_Address --
  75.    -------------------------
  76.  
  77.    procedure Set_Prim_Op_Address
  78.      (DTptr    : Tag;
  79.       Position : Positive;
  80.       Value    : System.Address)
  81.    is
  82.    begin
  83.       DTptr.Fptrs (Position) := Value;
  84.    end Set_Prim_Op_Address;
  85.  
  86.    -------------------------
  87.    -- Get_Prim_Op_Address --
  88.    -------------------------
  89.  
  90.    function Get_Prim_Op_Address
  91.      (DTptr    : Tag;
  92.       Position : Positive)
  93.      return      System.Address
  94.    is
  95.    begin
  96.       return DTptr.Fptrs (Position);
  97.    end Get_Prim_Op_Address;
  98.  
  99.    ---------------------------
  100.    -- Set_Inheritance_Depth --
  101.    ---------------------------
  102.  
  103.    procedure Set_Inheritance_Depth
  104.      (DTptr : Tag;
  105.       Value : Natural)
  106.    is
  107.    begin
  108.       DTptr.Idepth := Value;
  109.    end Set_Inheritance_Depth;
  110.  
  111.    ---------------------------
  112.    -- Set_Inheritance_Depth --
  113.    ---------------------------
  114.  
  115.    function Get_Inheritance_Depth (DTptr : Tag) return Natural is
  116.    begin
  117.       return DTptr.Idepth;
  118.    end Get_Inheritance_Depth;
  119.  
  120.    -------------------------
  121.    -- Set_Ancestor_DTptrs --
  122.    -------------------------
  123.  
  124.    procedure Set_Ancestor_Tags (DTptr : Tag; Value : System.Address) is
  125.    begin
  126.       DTptr.Tags := Value;
  127.    end Set_Ancestor_Tags;
  128.  
  129.    -----------------------
  130.    -- Get_Ancestor_Tags --
  131.    -----------------------
  132.  
  133.    function Get_Ancestor_Tags  (DTptr : Tag) return System.Address is
  134.    begin
  135.       return DTptr.Tags;
  136.    end Get_Ancestor_Tags;
  137.  
  138.    -------------
  139.    -- DT_Size --
  140.    -------------
  141.  
  142.    function DT_Size
  143.      (Entry_Count : Natural)
  144.       return        System.Storage_Elements.Storage_Count
  145.    is
  146.       type DT is record
  147.          Idepth : Natural;
  148.          Tags   : System.Address;
  149.          Fptrs  : Address_Array (1 .. Entry_Count);
  150.       end record;
  151.  
  152.    begin
  153.       return (DT'Size + System.Storage_Unit - 1) / System.Storage_Unit;
  154.    end DT_Size;
  155.  
  156.    ----------------
  157.    -- Inherit_DT --
  158.    ----------------
  159.  
  160.    procedure Inherit_DT
  161.     (Old_DTptr   : Tag;
  162.      New_DTptr   : Tag;
  163.      Entry_Count : Natural)
  164.    is
  165.    begin
  166.       --  Inherit primitive operations
  167.  
  168.       New_DTptr.Fptrs (1 .. Entry_Count) := Old_DTptr.Fptrs (1 .. Entry_Count);
  169.  
  170.       --  The inheritance depth is incremented
  171.  
  172.       New_DTptr.Idepth := Old_DTptr.Idepth + 1;
  173.  
  174.       --  The Ancestor Tags Table is also inherited (with a shift)
  175.  
  176.       To_Address_Array_Ptr (New_DTptr.Tags) (1 .. New_DTptr.Idepth)
  177.         := To_Address_Array_Ptr (Old_DTptr.Tags) (0 .. Old_DTptr.Idepth);
  178.  
  179.       To_Address_Array_Ptr (New_DTptr.Tags) (0) := To_Address (New_DTptr);
  180.    end Inherit_DT;
  181.  
  182.    --------------------
  183.    --  CW_Membership --
  184.    --------------------
  185.  
  186.    --  Canonical implementation of Classwide Membership corresponding to:
  187.  
  188.    --     Obj in Typ'Class
  189.  
  190.    --  Each dispatch table contains a reference to a table of ancestors
  191.    --  (Tags) and a count of the level of inheritance (Idepth). Obj is in
  192.    --  Typ'Class if Typ'Tag is in the table of ancestors contained in the
  193.    --  dispatch table referenced by Obj'Tag. Knowing the level of
  194.    --  inheritance of both types, this can be computed in constant time by
  195.    --  the formula: Obj'tag.Tags (Obj'tag.Idepth - Typ'tag.Idepth) = Typ'tag
  196.  
  197.    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
  198.       Pos : constant Integer := Obj_Tag.Idepth - Typ_Tag.Idepth;
  199.  
  200.    begin
  201.       return Pos >= 0 and then
  202.         To_Address_Array_Ptr (Obj_Tag.Tags) (Pos) = To_Address (Typ_Tag);
  203.    end CW_Membership;
  204. end Ada.Tags;
  205.